library(tidyverse)
library(AmesHousing)
library(recipes)
library(caret)
library(rpart)
library(rpart.plot)
library(ranger)
library(xgboost)
library(AUC)

Data prep

data("credit_data")

set.seed(42)
credit_data <- credit_data %>%
  mutate(
    base = if_else(runif(nrow(credit_data)) < 0.7, "treino", "teste")
  )

receita <- recipe(Status ~ ., data = credit_data %>% filter(base == "treino") %>% select(-base)) %>%
  step_meanimpute(all_numeric(), -all_outcomes()) %>%
  step_modeimpute(all_nominal(), -all_outcomes()) %>%
  step_dummy(all_nominal(), -all_outcomes()) %>%
  step_corr(all_predictors()) %>%
  step_nzv(all_predictors())

Árvore de decisão

getModelInfo("rpart", FALSE)$rpart
$label
[1] "CART"

$library
[1] "rpart"

$type
[1] "Regression"     "Classification"

$parameters

$grid
function(x, y, len = NULL, search = "grid"){
                    dat <- if(is.data.frame(x)) x else as.data.frame(x)
                    dat$.outcome <- y
                    initialFit <- rpart::rpart(.outcome ~ .,
                                               data = dat,
                                               control = rpart::rpart.control(cp = 0))$cptable
                    initialFit <- initialFit[order(-initialFit[,"CP"]), , drop = FALSE]
                    if(search == "grid") {
                      if(nrow(initialFit) < len) {
                        tuneSeq <- data.frame(cp = seq(min(initialFit[, "CP"]),
                                                       max(initialFit[, "CP"]),
                                                       length = len))
                      } else tuneSeq <-  data.frame(cp = initialFit[1:len,"CP"])
                      colnames(tuneSeq) <- "cp"
                    } else {
                      tuneSeq <- data.frame(cp = unique(sample(initialFit[, "CP"], size = len, replace = TRUE)))
                    }

                    tuneSeq
                  }

$loop
function(grid) {
                    grid <- grid[order(grid$cp, decreasing = FALSE),, drop = FALSE]
                    loop <- grid[1,,drop = FALSE]
                    submodels <- list(grid[-1,,drop = FALSE])
                    list(loop = loop, submodels = submodels)
                  }

$fit
function(x, y, wts, param, lev, last, classProbs, ...) {
                    cpValue <- if(!last) param$cp else 0
                    theDots <- list(...)
                    if(any(names(theDots) == "control"))
                    {
                      theDots$control$cp <- cpValue
                      theDots$control$xval <- 0
                      ctl <- theDots$control
                      theDots$control <- NULL
                    } else ctl <- rpart::rpart.control(cp = cpValue, xval = 0)

                    ## check to see if weights were passed in (and availible)
                    if(!is.null(wts)) theDots$weights <- wts

                    modelArgs <- c(list(formula = as.formula(".outcome ~ ."),
                                        data = if(is.data.frame(x)) x else as.data.frame(x),
                                        control = ctl),
                                   theDots)
                    modelArgs$data$.outcome <- y

                    out <- do.call(rpart::rpart, modelArgs)

                    if(last) out <- rpart::prune.rpart(out, cp = param$cp)
                    out
                  }

$predict
function(modelFit, newdata, submodels = NULL) {
                    if(!is.data.frame(newdata)) newdata <- as.data.frame(newdata)

                    pType <- if(modelFit$problemType == "Classification") "class" else "vector"
                    out  <- predict(modelFit, newdata, type=pType)

                    if(!is.null(submodels))
                    {
                      tmp <- vector(mode = "list", length = nrow(submodels) + 1)
                      tmp[[1]] <- out
                      for(j in seq(along = submodels$cp))
                      {
                        prunedFit <- rpart::prune.rpart(modelFit, cp = submodels$cp[j])
                        tmp[[j+1]]  <- predict(prunedFit, newdata, type=pType)
                      }
                      out <- tmp
                    }
                    out
                  }

$prob
function(modelFit, newdata, submodels = NULL) {
                    if(!is.data.frame(newdata)) newdata <- as.data.frame(newdata)
                    out <- predict(modelFit, newdata, type = "prob")

                    if(!is.null(submodels))
                    {
                      tmp <- vector(mode = "list", length = nrow(submodels) + 1)
                      tmp[[1]] <- out
                      for(j in seq(along = submodels$cp))
                      {
                        prunedFit <- rpart::prune.rpart(modelFit, cp = submodels$cp[j])
                        tmpProb <- predict(prunedFit, newdata, type = "prob")
                        tmp[[j+1]] <- as.data.frame(tmpProb[, modelFit$obsLevels, drop = FALSE])
                      }
                      out <- tmp
                    }
                    out
                  }

$predictors
function(x, surrogate = TRUE, ...)  {
                    out <- as.character(x$frame$var)
                    out <- out[!(out %in% c("<leaf>"))]
                    if(surrogate)
                    {
                      splits <- x$splits
                      splits <- splits[splits[,"adj"] > 0,]
                      out <- c(out, rownames(splits))
                    }
                    unique(out)
                  }

$varImp
function(object, surrogates = FALSE, competes = TRUE, ...) {
                    if(nrow(object$splits)>0) {
                      tmp <- rownames(object$splits)
                      rownames(object$splits) <- 1:nrow(object$splits)
                      splits <- data.frame(object$splits)
                      splits$var <- tmp
                      splits$type <- ""

                      frame <- as.data.frame(object$frame)
                      index <- 0
                      for(i in 1:nrow(frame)) {
                        if(frame$var[i] != "<leaf>") {
                          index <- index + 1
                          splits$type[index] <- "primary"
                          if(frame$ncompete[i] > 0) {
                            for(j in 1:frame$ncompete[i]) {
                              index <- index + 1
                              splits$type[index] <- "competing"
                            }
                          }
                          if(frame$nsurrogate[i] > 0) {
                            for(j in 1:frame$nsurrogate[i]) {
                              index <- index + 1
                              splits$type[index] <- "surrogate"
                            }
                          }
                        }
                      }
                      splits$var <- factor(as.character(splits$var))
                      if(!surrogates) splits <- subset(splits, type != "surrogate")
                      if(!competes) splits <- subset(splits, type != "competing")
                      out <- aggregate(splits$improve,
                                       list(Variable = splits$var),
                                       sum,
                                       na.rm = TRUE)
                    } else {
              out <- data.frame(x = numeric(), Vaiable = character())
            }
                    allVars <- colnames(attributes(object$terms)$factors)
                    if(!all(allVars %in% out$Variable)) {
                      missingVars <- allVars[!(allVars %in% out$Variable)]
                      zeros <- data.frame(x = rep(0, length(missingVars)),
                                          Variable = missingVars)
                      out <- rbind(out, zeros)
                    }
                    out2 <- data.frame(Overall = out$x)
                    rownames(out2) <- out$Variable
                    out2
                  }

$levels
function(x) x$obsLevels

$trim
function(x) {
                    x$call <- list(na.action = (x$call)$na.action)
                    x$x <- NULL
                    x$y <- NULL
                    x$where <- NULL
                    x
                  }

$tags
[1] "Tree-Based Model"              "Implicit Feature Selection"   
[3] "Handle Missing Predictor Data" "Accepts Case Weights"         

$sort
function(x) x[order(x[,1], decreasing = TRUE),]
train_control_rpart <- trainControl(
  method = "cv", 
  number = 5, 
  classProbs = TRUE,
  summaryFunction = twoClassSummary,
  verboseIter = 1 
)

# DICA: rode
# info <- getModelInfo("rpart", FALSE)$rpart
# info$parameters

grid_rpart <- data.frame(
  cp = seq(-0.001, 0.01, by= 0.0001)
)

modelo_rpart <- train(
  receita, 
  credit_data %>% filter(base == "treino") %>% select(-base), 
  method = "rpart", 
  metric = "ROC",
  trControl = train_control_rpart,
  tuneGrid = grid_rpart
)
Preparing recipe
+ Fold1: cp=-0.001 
- Fold1: cp=-0.001 
+ Fold2: cp=-0.001 
- Fold2: cp=-0.001 
+ Fold3: cp=-0.001 

Resultado

modelo_rpart
CART 

3070 samples
  13 predictor
   2 classes: 'bad', 'good' 

Recipe steps: meanimpute, modeimpute, dummy, corr, nzv 
Resampling: Cross-Validated (5 fold) 
Summary of sample sizes: 2456, 2455, 2457, 2457, 2455 
Resampling results across tuning parameters:

  cp       ROC        Sens       Spec     
  -0.0010  0.7385880  0.4976746  0.8292404
  -0.0009  0.7385880  0.4976746  0.8292404
  -0.0008  0.7385880  0.4976746  0.8292404
  -0.0007  0.7385880  0.4976746  0.8292404
  -0.0006  0.7385880  0.4976746  0.8292404
  -0.0005  0.7385880  0.4976746  0.8292404
  -0.0004  0.7385880  0.4976746  0.8292404
  -0.0003  0.7385880  0.4976746  0.8292404
  -0.0002  0.7385880  0.4976746  0.8292404
  -0.0001  0.7385880  0.4976746  0.8292404
   0.0000  0.7530080  0.4838416  0.8419563
   0.0001  0.7530080  0.4838416  0.8419563
   0.0002  0.7530080  0.4838416  0.8419563
   0.0003  0.7508616  0.4815428  0.8428633
   0.0004  0.7497139  0.4792373  0.8460431
   0.0005  0.7459665  0.4838350  0.8460431
   0.0006  0.7468441  0.4815228  0.8474067
   0.0007  0.7468441  0.4815228  0.8474067
   0.0008  0.7527045  0.4734768  0.8619470
   0.0009  0.7527045  0.4734768  0.8619470
   0.0010  0.7512653  0.4734768  0.8637652
   0.0011  0.7519638  0.4757757  0.8646722
   0.0012  0.7519638  0.4757757  0.8646722
   0.0013  0.7519638  0.4757757  0.8646722
   0.0014  0.7519638  0.4757757  0.8646722
   0.0015  0.7546083  0.4758355  0.8728458
   0.0016  0.7546083  0.4758355  0.8728458
   0.0017  0.7546083  0.4758355  0.8728458
   0.0018  0.7546083  0.4758355  0.8728458
   0.0019  0.7546083  0.4758355  0.8728458
   0.0020  0.7513883  0.4723939  0.8728458
   0.0021  0.7513883  0.4723939  0.8728458
   0.0022  0.7520362  0.4781676  0.8737580
   0.0023  0.7520362  0.4781676  0.8737580
   0.0024  0.7515843  0.4793236  0.8742125
   0.0025  0.7502133  0.4804731  0.8769336
   0.0026  0.7503254  0.4804731  0.8778407
   0.0027  0.7477346  0.4701282  0.8792012
   0.0028  0.7477346  0.4701282  0.8792012
   0.0029  0.7503338  0.4563218  0.8837374
   0.0030  0.7503338  0.4563218  0.8837374
   0.0031  0.7503338  0.4563218  0.8837374
   0.0032  0.7503338  0.4563218  0.8837374
   0.0033  0.7503338  0.4563218  0.8837374
   0.0034  0.7507174  0.4563218  0.8837374
   0.0035  0.7503456  0.4540097  0.8855556
   0.0036  0.7511207  0.4540097  0.8846465
   0.0037  0.7465225  0.4413660  0.8923593
   0.0038  0.7465225  0.4413660  0.8923593
   0.0039  0.7408048  0.4367550  0.8932684
   0.0040  0.7335255  0.4309747  0.8964502
   0.0041  0.7335255  0.4309747  0.8964502
   0.0042  0.7335255  0.4309747  0.8964502
   0.0043  0.7335255  0.4309747  0.8964502
   0.0044  0.7336564  0.4240516  0.8946403
   0.0045  0.7336564  0.4240516  0.8946403
   0.0046  0.7320066  0.4206033  0.8973614
   0.0047  0.7320066  0.4206033  0.8973614
   0.0048  0.7313576  0.4206033  0.8982705
   0.0049  0.7290796  0.4160056  0.8996341
   0.0050  0.7290796  0.4160056  0.8996341
   0.0051  0.7286288  0.4343964  0.8896547
   0.0052  0.7286288  0.4343964  0.8896547
   0.0053  0.7297652  0.4286493  0.8928293
   0.0054  0.7297652  0.4286493  0.8928293
   0.0055  0.7297652  0.4286493  0.8928293
   0.0056  0.7297652  0.4286493  0.8928293
   0.0057  0.7297652  0.4286493  0.8928293
   0.0058  0.7298794  0.4147831  0.8964616
   0.0059  0.7298794  0.4147831  0.8964616
   0.0060  0.7298794  0.4147831  0.8964616
   0.0061  0.7298794  0.4147831  0.8964616
   0.0062  0.7298794  0.4147831  0.8964616
   0.0063  0.7298794  0.4147831  0.8964616
   0.0064  0.7298794  0.4147831  0.8964616
   0.0065  0.7302964  0.4216796  0.8928334
   0.0066  0.7302964  0.4216796  0.8928334
   0.0067  0.7302964  0.4216796  0.8928334
   0.0068  0.7302964  0.4216796  0.8928334
   0.0069  0.7172084  0.4090359  0.9000897
   0.0070  0.7172084  0.4090359  0.9000897
   0.0071  0.7172084  0.4090359  0.9000897
   0.0072  0.7164385  0.4067238  0.8982715
   0.0073  0.7177774  0.4228158  0.8955442
   0.0074  0.7177774  0.4228158  0.8955442
   0.0075  0.7177774  0.4228158  0.8955442
   0.0076  0.7177774  0.4228158  0.8955442
   0.0077  0.7177774  0.4228158  0.8955442
   0.0078  0.7177774  0.4228158  0.8955442
   0.0079  0.7177774  0.4228158  0.8955442
   0.0080  0.7177774  0.4228158  0.8955442
   0.0081  0.7177774  0.4228158  0.8955442
   0.0082  0.7177774  0.4228158  0.8955442
   0.0083  0.7177774  0.4228158  0.8955442
   0.0084  0.7177774  0.4228158  0.8955442
   0.0085  0.7177774  0.4228158  0.8955442
   0.0086  0.7177774  0.4228158  0.8955442
   0.0087  0.6905127  0.3848914  0.9023645
   0.0088  0.6905127  0.3848914  0.9023645
   0.0089  0.6905127  0.3848914  0.9023645
   0.0090  0.6905127  0.3848914  0.9023645
   0.0091  0.6905127  0.3848914  0.9023645
   0.0092  0.6905127  0.3848914  0.9023645
   0.0093  0.6905127  0.3848914  0.9023645
   0.0094  0.6881358  0.3641153  0.9078149
   0.0095  0.6881358  0.3641153  0.9078149
   0.0096  0.6881358  0.3641153  0.9078149
   0.0097  0.6881358  0.3641153  0.9078149
   0.0098  0.6881358  0.3641153  0.9078149
   0.0099  0.6881358  0.3641153  0.9078149
   0.0100  0.6881358  0.3641153  0.9078149

ROC was used to select the optimal model using the largest value.
The final value used for the model was cp = 0.0019.
modelo_rpart$bestTune
varImp(modelo_rpart)
rpart variable importance
plot(modelo_rpart)

# apenas para arvores
rpart.plot(modelo_rpart$finalModel)
pdf("arvore.pdf", 20, 10)
rpart.plot(modelo_rpart$finalModel)
dev.off()
png 
  2 

# Matriz de confusão
credit_data <- credit_data %>% 
  mutate(
    pred_rpart = predict(modelo_rpart, ., type = "prob")$bad
  )

credit_data_teste <- credit_data %>% filter(base %in% "teste")
caret::confusionMatrix(
  predict(modelo_rpart, credit_data_teste), 
  credit_data_teste$Status, 
  mode = "everything"
)
Confusion Matrix and Statistics

          Reference
Prediction bad good
      bad  185  119
      good 201  879
                                          
               Accuracy : 0.7688          
                 95% CI : (0.7457, 0.7908)
    No Information Rate : 0.7211          
    P-Value [Acc > NIR] : 3.213e-05       
                                          
                  Kappa : 0.3851          
                                          
 Mcnemar's Test P-Value : 5.953e-06       
                                          
            Sensitivity : 0.4793          
            Specificity : 0.8808          
         Pos Pred Value : 0.6086          
         Neg Pred Value : 0.8139          
              Precision : 0.6086          
                 Recall : 0.4793          
                     F1 : 0.5362          
             Prevalence : 0.2789          
         Detection Rate : 0.1337          
   Detection Prevalence : 0.2197          
      Balanced Accuracy : 0.6800          
                                          
       'Positive' Class : bad             
                                          

roc_rpart$roc %>% walk(plot)

# gráfico extra ---- cuidado: códigos de R avançados!
roc_plot <- roc_rpart %>%
  select(base, roc, auc) %>%
  mutate(
    roc = map(roc, ~{
      .x %>% 
        unclass %>% 
        as.data.frame
    })
  ) %>%
  unnest %>%
  ggplot(aes(x = fpr, y = tpr, colour = base, label = cutoffs)) +
  geom_line() +
  geom_abline(colour = "grey50") +
  theme_minimal() +
  coord_fixed()

plotly::ggplotly(roc_plot)

Random Forest

infos <- getModelInfo("ranger", FALSE)$ranger
save(modelo_rf, "modelo_rf.RData")
Error in save(modelo_rf, "modelo_rf.RData") : 
  objeto ‘modelo_rf.RData’ não encontrado

Resultado

varImp(modelo_rf)
ranger variable importance
# Predicoes

credit_data <- credit_data %>% 
  mutate(
    pred_rf = predict(modelo_rf, ., type = "prob")$bad
  )
# Matriz de confusão
credit_data_teste <- credit_data %>% filter(base %in% "teste")
caret::confusionMatrix(predict(modelo_rf, credit_data_teste), credit_data_teste$Status, mode = "everything")
Confusion Matrix and Statistics

          Reference
Prediction bad good
      bad  180   79
      good 206  919
                                          
               Accuracy : 0.7941          
                 95% CI : (0.7718, 0.8151)
    No Information Rate : 0.7211          
    P-Value [Acc > NIR] : 2.703e-10       
                                          
                  Kappa : 0.4306          
                                          
 Mcnemar's Test P-Value : 8.419e-14       
                                          
            Sensitivity : 0.4663          
            Specificity : 0.9208          
         Pos Pred Value : 0.6950          
         Neg Pred Value : 0.8169          
              Precision : 0.6950          
                 Recall : 0.4663          
                     F1 : 0.5581          
             Prevalence : 0.2789          
         Detection Rate : 0.1301          
   Detection Prevalence : 0.1871          
      Balanced Accuracy : 0.6936          
                                          
       'Positive' Class : bad             
                                          
# Comparacao de modelos
rocs %>%
  ggplot(aes(x = auc, y = modelo, colour = base)) +
  geom_point(size = 5) +
  theme_minimal(30)

# gráfico extra ---- cuidado: códigos de R avançados!
roc_plot <- rocs %>%
  select(base, modelo, roc) %>%
  mutate(
    roc = map(roc, ~{
      .x %>% 
        unclass %>% 
        as.data.frame
    })
  ) %>%
  unnest %>%
  ggplot(aes(x = fpr, y = tpr, colour = modelo, label = cutoffs)) +
  geom_line() +
  geom_abline(colour = "grey50") +
  theme_minimal() +
  coord_fixed() +
  facet_wrap(~base)

plotly::ggplotly(roc_plot)

XGBoost

Exercício: Ajuste um xgboost usando o caret e responda: qual modelo apresenta a maior AUC? crtl+C ctrl+V por sua conta!

DICA 1) troque “ranger” por “xgbTree” DICA 2) rode info <- getModelInfo("xgbTree", FALSE)$xgbTree e depois consulte info$parameters. DICA 3) experimente usar o parâmetro tuneLength = 20 em vez do `tuneGrid.

getModelInfo("xgbTree", FALSE)$xgbTree
$label
[1] "eXtreme Gradient Boosting"

$library
[1] "xgboost" "plyr"   

$type
[1] "Regression"     "Classification"

$parameters

$grid
function(x, y, len = NULL, search = "grid") {
                    if(search == "grid") {
                      out <- expand.grid(max_depth = seq(1, len),
                                         nrounds = floor((1:len) * 50),
                                         eta = c(.3, .4),
                                         gamma = 0,
                                         colsample_bytree = c(.6, .8),
                                         min_child_weight = c(1),
                                         subsample = seq(.5, 1, length = len))
                    } else {
                      out <- data.frame(nrounds = sample(1:1000, size = len, replace = TRUE),
                                        max_depth = sample(1:10, replace = TRUE, size = len),
                                        eta = runif(len, min = .001, max = .6),
                                        gamma = runif(len, min = 0, max = 10),
                                        colsample_bytree = runif(len, min = .3, max = .7),
                                        min_child_weight = sample(0:20, size = len, replace = TRUE),
                                        subsample = runif(len, min = .25, max = 1))
                      out$nrounds <- floor(out$nrounds)
                      out <- out[!duplicated(out),]
                    }
                    out
                  }

$loop
function(grid) {
                    loop <- plyr::ddply(grid, c("eta", "max_depth", "gamma",
                                          "colsample_bytree", "min_child_weight",
                                          "subsample"),
                                  function(x) c(nrounds = max(x$nrounds)))
                    submodels <- vector(mode = "list", length = nrow(loop))
                    for(i in seq(along = loop$nrounds)) {
                      index <- which(grid$max_depth == loop$max_depth[i] &
                                       grid$eta == loop$eta[i] &
                                       grid$gamma == loop$gamma[i] &
                                       grid$colsample_bytree == loop$colsample_bytree[i] &
                                       grid$min_child_weight == loop$min_child_weight[i] &
                                       grid$subsample == loop$subsample[i])
                      trees <- grid[index, "nrounds"]
                      submodels[[i]] <- data.frame(nrounds = trees[trees != loop$nrounds[i]])
                    }
                    list(loop = loop, submodels = submodels)
                  }

$fit
function(x, y, wts, param, lev, last, classProbs, ...) {
                    if(!inherits(x, "xgb.DMatrix"))
                      x <- as.matrix(x)
                    
                    if(is.factor(y)) {
                      
                      if(length(lev) == 2) {
                        
                        y <- ifelse(y == lev[1], 1, 0)

                        if(!inherits(x, "xgb.DMatrix"))
                          x <- xgboost::xgb.DMatrix(x, label = y, missing = NA) else
                            xgboost::setinfo(x, "label", y)
                        
                        if (!is.null(wts))
                          xgboost::setinfo(x, 'weight', wts)
                        
                        out <- xgboost::xgb.train(list(eta = param$eta,
                                                       max_depth = param$max_depth,
                                                       gamma = param$gamma,
                                                       colsample_bytree = param$colsample_bytree,
                                                       min_child_weight = param$min_child_weight,
                                                       subsample = param$subsample),
                                                  data = x,
                                                  nrounds = param$nrounds,
                                                  objective = "binary:logistic",
                                                  ...)
                      } else {
                        
                        y <- as.numeric(y) - 1

                        if(!inherits(x, "xgb.DMatrix"))
                          x <- xgboost::xgb.DMatrix(x, label = y, missing = NA) else
                            xgboost::setinfo(x, "label", y)
                        
                        if (!is.null(wts))
                          xgboost::setinfo(x, 'weight', wts)
                        
                        out <- xgboost::xgb.train(list(eta = param$eta,
                                                       max_depth = param$max_depth,
                                                       gamma = param$gamma,
                                                       colsample_bytree = param$colsample_bytree,
                                                       min_child_weight = param$min_child_weight,
                                                       subsample = param$subsample),
                                                       data = x,
                                                       num_class = length(lev),
                                                       nrounds = param$nrounds,
                                                       objective = "multi:softprob",
                                                       ...)
                      }
                    } else {

                      if(!inherits(x, "xgb.DMatrix"))
                        x <- xgboost::xgb.DMatrix(x, label = y, missing = NA) else
                          xgboost::setinfo(x, "label", y)
                      
                      if (!is.null(wts))
                        xgboost::setinfo(x, 'weight', wts)
                      
                      out <- xgboost::xgb.train(list(eta = param$eta,
                                                     max_depth = param$max_depth,
                                                     gamma = param$gamma,
                                                     colsample_bytree = param$colsample_bytree,
                                                     min_child_weight = param$min_child_weight,
                                                     subsample = param$subsample),
                                                 data = x,
                                                 nrounds = param$nrounds,
                                                 objective = "reg:linear",
                                                 ...)
                    }
                    out
                    
                    
                  }

$predict
function(modelFit, newdata, submodels = NULL) {
                    if(!inherits(newdata, "xgb.DMatrix")) {
                      newdata <- as.matrix(newdata)
                      newdata <- xgboost::xgb.DMatrix(data=newdata, missing = NA)
                    }
                   out <- predict(modelFit, newdata)
                    if(modelFit$problemType == "Classification") {
                      if(length(modelFit$obsLevels) == 2) {
                        out <- ifelse(out >= .5,
                                      modelFit$obsLevels[1],
                                      modelFit$obsLevels[2])
                      } else {
                        out <- matrix(out, ncol = length(modelFit$obsLevels), byrow = TRUE)
                        out <- modelFit$obsLevels[apply(out, 1, which.max)]
                      }
                    }
                    
                    if(!is.null(submodels)) {
                      tmp <- vector(mode = "list", length = nrow(submodels) + 1)
                      tmp[[1]] <- out
                      for(j in seq(along = submodels$nrounds)) {
                        tmp_pred <- predict(modelFit, newdata, ntreelimit = submodels$nrounds[j])
                        if(modelFit$problemType == "Classification") {
                          if(length(modelFit$obsLevels) == 2) {
                            tmp_pred <- ifelse(tmp_pred >= .5,
                                               modelFit$obsLevels[1],
                                               modelFit$obsLevels[2])
                          } else {
                            tmp_pred <- matrix(tmp_pred, ncol = length(modelFit$obsLevels), byrow = TRUE)
                            tmp_pred <- modelFit$obsLevels[apply(tmp_pred, 1, which.max)]
                          }
                        }
                        tmp[[j+1]]  <- tmp_pred
                      }
                      out <- tmp
                    }
                    out
                  }

$prob
function(modelFit, newdata, submodels = NULL) {
                    if(!inherits(newdata, "xgb.DMatrix")) {
                      newdata <- as.matrix(newdata)
                      newdata <- xgboost::xgb.DMatrix(data=newdata, missing = NA)
                    }
                    
                    if( !is.null(modelFit$param$objective) && modelFit$param$objective == 'binary:logitraw'){
                      p <- predict(modelFit, newdata)
                      out <-binomial()$linkinv(p) # exp(p)/(1+exp(p))
                    } else {
                      out <- predict(modelFit, newdata)
                    }
                   if(length(modelFit$obsLevels) == 2) {
                     out <- cbind(out, 1 - out)
                      colnames(out) <- modelFit$obsLevels
                    } else {
                      out <- matrix(out, ncol = length(modelFit$obsLevels), byrow = TRUE)
                      colnames(out) <- modelFit$obsLevels
                    }
                    out <- as.data.frame(out)
                    
                    if(!is.null(submodels)) {
                      tmp <- vector(mode = "list", length = nrow(submodels) + 1)
                      tmp[[1]] <- out
                      for(j in seq(along = submodels$nrounds)) {
                        tmp_pred <- predict(modelFit, newdata, ntreelimit = submodels$nrounds[j])
                        if(length(modelFit$obsLevels) == 2) {
                          tmp_pred <- cbind(tmp_pred, 1 - tmp_pred)
                          colnames(tmp_pred) <- modelFit$obsLevels
                        } else {
                          tmp_pred <- matrix(tmp_pred, ncol = length(modelFit$obsLevels), byrow = TRUE)
                          colnames(tmp_pred) <- modelFit$obsLevels
                        }
                        tmp_pred <- as.data.frame(tmp_pred)
                        tmp[[j+1]]  <- tmp_pred
                      }
                      out <- tmp
                    }
                    out
                  }

$predictors
function(x, ...) {
                    imp <- xgboost::xgb.importance(x$xNames, model = x)
                    x$xNames[x$xNames %in% imp$Feature]
                  }

$varImp
function(object, numTrees = NULL, ...) {
                    imp <- xgboost::xgb.importance(object$xNames, model = object)
                    imp <- as.data.frame(imp)[, 1:2]
                    rownames(imp) <- as.character(imp[,1])
                    imp <- imp[,2,drop = FALSE]
                    colnames(imp) <- "Overall"
                    
                    missing <- object$xNames[!(object$xNames %in% rownames(imp))]
                    missing_imp <- data.frame(Overall=rep(0, times=length(missing)))
                    rownames(missing_imp) <- missing
                    imp <- rbind(imp, missing_imp)
                    
                    imp
                  }

$levels
function(x) x$obsLevels

$tags
[1] "Tree-Based Model"           "Boosting"                  
[3] "Ensemble Model"             "Implicit Feature Selection"
[5] "Accepts Case Weights"      

$sort
function(x) {
                    # This is a toss-up, but the # trees probably adds
                    # complexity faster than number of splits
                    x[order(x$nrounds, x$max_depth, x$eta, x$gamma, x$colsample_bytree, x$min_child_weight),]
                  }
train_control_xgb <- trainControl(
  method = "cv",
  number = 5,
  classProbs = TRUE,
  summaryFunction = twoClassSummary,
  verboseIter = 1,
  search = "random"
)
modelo_xgb <- train(
  receita,
  credit_data %>% filter(base %in% "treino") %>% select(-base),
  method = "xgbTree", #PREENCHA AQUI
  metric = "ROC",
  trControl = train_control_xgb,
  tuneGrid = tune_grid_xgb
)
Preparing recipe
+ Fold1: eta=0.010, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold1: eta=0.010, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold1: eta=0.100, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold1: eta=0.100, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold1: eta=0.146, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold1: eta=0.146, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold1: eta=0.500, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold1: eta=0.500, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold1: eta=1.000, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold1: eta=1.000, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold2: eta=0.010, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold2: eta=0.010, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold2: eta=0.100, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold2: eta=0.100, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold2: eta=0.146, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold2: eta=0.146, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold2: eta=0.500, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold2: eta=0.500, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold2: eta=1.000, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
- Fold2: eta=1.000, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 
+ Fold3: eta=0.010, max_depth=6, gamma=5.638, colsample_bytree=0.4464, min_child_weight=19, subsample=0.9128, nrounds=1200 

LS0tCnRpdGxlOiAiw4Fydm9yZSwgUmFuZG9tIEZvcmVzdCBlIFhHQm9vc3QiCm91dHB1dDogaHRtbF9ub3RlYm9vawotLS0KCmBgYHtyLCB3YXJuaW5nPUZBTFNFLCBtZXNzYWdlPUZBTFNFfQpsaWJyYXJ5KHRpZHl2ZXJzZSkKbGlicmFyeShBbWVzSG91c2luZykKbGlicmFyeShyZWNpcGVzKQpsaWJyYXJ5KGNhcmV0KQpsaWJyYXJ5KHJwYXJ0KQpsaWJyYXJ5KHJwYXJ0LnBsb3QpCmxpYnJhcnkocmFuZ2VyKQpsaWJyYXJ5KHhnYm9vc3QpCmxpYnJhcnkoQVVDKQpgYGAKCiMgRGF0YSBwcmVwCgpgYGB7cn0KZGF0YSgiY3JlZGl0X2RhdGEiKQoKc2V0LnNlZWQoNDIpCmNyZWRpdF9kYXRhIDwtIGNyZWRpdF9kYXRhICU+JQogIG11dGF0ZSgKICAgIGJhc2UgPSBpZl9lbHNlKHJ1bmlmKG5yb3coY3JlZGl0X2RhdGEpKSA8IDAuNywgInRyZWlubyIsICJ0ZXN0ZSIpCiAgKQoKcmVjZWl0YSA8LSByZWNpcGUoU3RhdHVzIH4gLiwgZGF0YSA9IGNyZWRpdF9kYXRhICU+JSBmaWx0ZXIoYmFzZSA9PSAidHJlaW5vIikgJT4lIHNlbGVjdCgtYmFzZSkpICU+JQogIHN0ZXBfbWVhbmltcHV0ZShhbGxfbnVtZXJpYygpLCAtYWxsX291dGNvbWVzKCkpICU+JQogIHN0ZXBfbW9kZWltcHV0ZShhbGxfbm9taW5hbCgpLCAtYWxsX291dGNvbWVzKCkpICU+JQogIHN0ZXBfZHVtbXkoYWxsX25vbWluYWwoKSwgLWFsbF9vdXRjb21lcygpKSAlPiUKICBzdGVwX2NvcnIoYWxsX3ByZWRpY3RvcnMoKSkgJT4lCiAgc3RlcF9uenYoYWxsX3ByZWRpY3RvcnMoKSkKYGBgCgoKIyDDgXJ2b3JlIGRlIGRlY2lzw6NvCgpgYGB7cn0KZ2V0TW9kZWxJbmZvKCJycGFydCIsIEZBTFNFKSRycGFydApgYGAKCmBgYHtyfQp0cmFpbl9jb250cm9sX3JwYXJ0IDwtIHRyYWluQ29udHJvbCgKICBtZXRob2QgPSAiY3YiLCAKICBudW1iZXIgPSA1LCAKICBjbGFzc1Byb2JzID0gVFJVRSwKICBzdW1tYXJ5RnVuY3Rpb24gPSB0d29DbGFzc1N1bW1hcnksCiAgdmVyYm9zZUl0ZXIgPSAxIAopCgojIERJQ0E6IHJvZGUKIyBpbmZvIDwtIGdldE1vZGVsSW5mbygicnBhcnQiLCBGQUxTRSkkcnBhcnQKIyBpbmZvJHBhcmFtZXRlcnMKCmdyaWRfcnBhcnQgPC0gZGF0YS5mcmFtZSgKICBjcCA9IHNlcSgtMC4wMDEsIDAuMDEsIGJ5PSAwLjAwMDEpCikKCm1vZGVsb19ycGFydCA8LSB0cmFpbigKICByZWNlaXRhLCAKICBjcmVkaXRfZGF0YSAlPiUgZmlsdGVyKGJhc2UgPT0gInRyZWlubyIpICU+JSBzZWxlY3QoLWJhc2UpLCAKICBtZXRob2QgPSAicnBhcnQiLCAKICBtZXRyaWMgPSAiUk9DIiwKICB0ckNvbnRyb2wgPSB0cmFpbl9jb250cm9sX3JwYXJ0LAogIHR1bmVHcmlkID0gZ3JpZF9ycGFydAopCmBgYAoKIyMgUmVzdWx0YWRvCgpgYGB7cn0KbW9kZWxvX3JwYXJ0Cm1vZGVsb19ycGFydCRiZXN0VHVuZQp2YXJJbXAobW9kZWxvX3JwYXJ0KQpwbG90KG1vZGVsb19ycGFydCkKYGBgCgpgYGB7cn0KIyBhcGVuYXMgcGFyYSBhcnZvcmVzCnJwYXJ0LnBsb3QobW9kZWxvX3JwYXJ0JGZpbmFsTW9kZWwpCnBkZigiYXJ2b3JlLnBkZiIsIDIwLCAxMCkKcnBhcnQucGxvdChtb2RlbG9fcnBhcnQkZmluYWxNb2RlbCkKZGV2Lm9mZigpCmBgYAoKCmBgYHtyfQojIE1hdHJpeiBkZSBjb25mdXPDo28KY3JlZGl0X2RhdGEgPC0gY3JlZGl0X2RhdGEgJT4lIAogIG11dGF0ZSgKICAgIHByZWRfcnBhcnQgPSBwcmVkaWN0KG1vZGVsb19ycGFydCwgLiwgdHlwZSA9ICJwcm9iIikkYmFkCiAgKQoKY3JlZGl0X2RhdGFfdGVzdGUgPC0gY3JlZGl0X2RhdGEgJT4lIGZpbHRlcihiYXNlICVpbiUgInRlc3RlIikKY2FyZXQ6OmNvbmZ1c2lvbk1hdHJpeCgKICBwcmVkaWN0KG1vZGVsb19ycGFydCwgY3JlZGl0X2RhdGFfdGVzdGUpLCAKICBjcmVkaXRfZGF0YV90ZXN0ZSRTdGF0dXMsIAogIG1vZGUgPSAiZXZlcnl0aGluZyIKKQpgYGAKCmBgYHtyfQojIEN1cnZhIFJPQwpjcmVkaXRfZGF0YV90ZXN0ZSA8LSBjcmVkaXRfZGF0YSAlPiUKICBmaWx0ZXIoYmFzZSAlaW4lICJ0ZXN0ZSIpICU+JQogIG11dGF0ZSgKICAgIFN0YXR1c19wYXJhX3JvYyA9IGZhY3RvcihpZl9lbHNlKFN0YXR1cyA9PSAiZ29vZCIsIDAsIDEpKQogICkgCgpyb2NfdGVzdGUgPC0gcm9jKAogIGNyZWRpdF9kYXRhX3Rlc3RlJHByZWRfcnBhcnQsIAogIGNyZWRpdF9kYXRhX3Rlc3RlJFN0YXR1c19wYXJhX3JvYwopCkFVQzo6YXVjKHJvY190ZXN0ZSkKcGxvdChyb2NfdGVzdGUpCmBgYAoKCmBgYHtyfQojY3VydmEgUk9DIGV4dHJhICAtLS0tIGN1aWRhZG86IGPDs2RpZ29zIGRlIFIgYXZhbsOnYWRvcyEKcm9jX3JwYXJ0IDwtIGNyZWRpdF9kYXRhICU+JQogIG11dGF0ZSgKICAgIFN0YXR1c19wYXJhX3JvYyA9IGZhY3RvcihpZl9lbHNlKFN0YXR1cyA9PSAiZ29vZCIsIDAsIDEpKQogICkgJT4lCiAgZ3JvdXBfYnkoYmFzZSkgJT4lCiAgbmVzdCgpICU+JQogIG11dGF0ZSgKICAgIHJvYyA9IG1hcChkYXRhLCB+IEFVQzo6cm9jKC54JHByZWRfcnBhcnQsIC54JFN0YXR1c19wYXJhX3JvYykpLAogICAgYXVjID0gbWFwX2RibChyb2MsIEFVQzo6YXVjKQogICkKcm9jX3JwYXJ0CmBgYAoKCmBgYHtyfQpyb2NfcnBhcnQkcm9jICU+JSB3YWxrKHBsb3QpCmBgYAoKYGBge3J9CiMgZ3LDoWZpY28gZXh0cmEgLS0tLSBjdWlkYWRvOiBjw7NkaWdvcyBkZSBSIGF2YW7Dp2Fkb3MhCnJvY19wbG90IDwtIHJvY19ycGFydCAlPiUKICBzZWxlY3QoYmFzZSwgcm9jLCBhdWMpICU+JQogIG11dGF0ZSgKICAgIHJvYyA9IG1hcChyb2MsIH57CiAgICAgIC54ICU+JSAKICAgICAgICB1bmNsYXNzICU+JSAKICAgICAgICBhcy5kYXRhLmZyYW1lCiAgICB9KQogICkgJT4lCiAgdW5uZXN0ICU+JQogIGdncGxvdChhZXMoeCA9IGZwciwgeSA9IHRwciwgY29sb3VyID0gYmFzZSwgbGFiZWwgPSBjdXRvZmZzKSkgKwogIGdlb21fbGluZSgpICsKICBnZW9tX2FibGluZShjb2xvdXIgPSAiZ3JleTUwIikgKwogIHRoZW1lX21pbmltYWwoKSArCiAgY29vcmRfZml4ZWQoKQoKcGxvdGx5OjpnZ3Bsb3RseShyb2NfcGxvdCkKYGBgCgoKIyBSYW5kb20gRm9yZXN0IApgYGB7cn0KaW5mb3MgPC0gZ2V0TW9kZWxJbmZvKCJyYW5nZXIiLCBGQUxTRSkkcmFuZ2VyCgpgYGAKCmBgYHtyfQp0cmFpbl9jb250cm9sX3JmIDwtIHRyYWluQ29udHJvbCgKICBtZXRob2QgPSAiY3YiLAogIG51bWJlciA9IDUsCiAgY2xhc3NQcm9icyA9IFRSVUUsCiAgc3VtbWFyeUZ1bmN0aW9uID0gdHdvQ2xhc3NTdW1tYXJ5LAogIHZlcmJvc2VJdGVyID0gMQopCgojIERJQ0E6IHJvZGUKIyBpbmZvIDwtIGdldE1vZGVsSW5mbygicmFuZ2VyIiwgRkFMU0UpJHJhbmdlcgojIGluZm8kcGFyYW1ldGVycwojIAojIGdyaWRfcmYgPC0gZXhwYW5kLmdyaWQoCiMgICBtdHJ5ID0gYygyLCA0LCA2KSwgIyBQUkVFTkNIQSBBUVVJCiMgICBtaW4ubm9kZS5zaXplID0gc2VxKDEwLCAxMDAsIGJ5ID0gMjApLAojICAgc3BsaXRydWxlID0gImdpbmkiCiMgKQoKbW9kZWxvX3JmIDwtIHRyYWluKAogIHJlY2VpdGEsCiAgY3JlZGl0X2RhdGEgJT4lIGZpbHRlcihiYXNlICVpbiUgInRyZWlubyIpICU+JSBzZWxlY3QoLWJhc2UpLAogIG1ldGhvZCA9ICJyYW5nZXIiLCAjUFJFRU5DSEEgQVFVSQogIGltcG9ydGFuY2UgPSAicGVybXV0YXRpb24iLAogIG1ldHJpYyA9ICJST0MiLAogIHRyQ29udHJvbCA9IHRyYWluX2NvbnRyb2xfcmYsCiAgdHVuZUxlbmd0aCA9IDIwCikKCnNhdmUobW9kZWxvX3JmLCBmaWxlID0gIm1vZGVsb19yZi5SRGF0YSIpCgpsb2FkKCJtb2RlbG9fcmYuUkRhdGEiKQpgYGAKCiMjIFJlc3VsdGFkbwpgYGB7cn0KbW9kZWxvX3JmCm1vZGVsb19yZiRiZXN0VHVuZQp2YXJJbXAobW9kZWxvX3JmKQpwbG90KG1vZGVsb19yZikKYGBgCgpgYGB7cn0KIyBQcmVkaWNvZXMKCmNyZWRpdF9kYXRhIDwtIGNyZWRpdF9kYXRhICU+JSAKICBtdXRhdGUoCiAgICBwcmVkX3JmID0gcHJlZGljdChtb2RlbG9fcmYsIC4sIHR5cGUgPSAicHJvYiIpJGJhZAogICkKYGBgCgoKYGBge3J9CiMgTWF0cml6IGRlIGNvbmZ1c8OjbwpjcmVkaXRfZGF0YV90ZXN0ZSA8LSBjcmVkaXRfZGF0YSAlPiUgZmlsdGVyKGJhc2UgJWluJSAidGVzdGUiKQpjYXJldDo6Y29uZnVzaW9uTWF0cml4KHByZWRpY3QobW9kZWxvX3JmLCBjcmVkaXRfZGF0YV90ZXN0ZSksIGNyZWRpdF9kYXRhX3Rlc3RlJFN0YXR1cywgbW9kZSA9ICJldmVyeXRoaW5nIikKYGBgCgpgYGB7cn0KI2N1cnZhIFJPQyAgLS0tLSBjdWlkYWRvOiBjw7NkaWdvcyBkZSBSIGF2YW7Dp2Fkb3MhCnJvY3MgPC0gY3JlZGl0X2RhdGEgJT4lCiAgbXV0YXRlKAogICAgU3RhdHVzX3BhcmFfcm9jID0gZmFjdG9yKGlmX2Vsc2UoU3RhdHVzID09ICJnb29kIiwgMCwgMSkpCiAgKSAlPiUKICBzZWxlY3QoYmFzZSwgU3RhdHVzX3BhcmFfcm9jLCBzdGFydHNfd2l0aCgicHJlZCIpKSAlPiUKICBnYXRoZXIobW9kZWxvLCB2YWxvcl9wcmVkaXRvLCBzdGFydHNfd2l0aCgicHJlZCIpKSAlPiUKICBncm91cF9ieShiYXNlLCBtb2RlbG8pICU+JQogIG5lc3QoKSAlPiUKICBtdXRhdGUoCiAgICByb2MgPSBtYXAoZGF0YSwgfiBBVUM6OnJvYygueCR2YWxvcl9wcmVkaXRvLCAueCRTdGF0dXNfcGFyYV9yb2MpKSwKICAgIGF1YyA9IG1hcF9kYmwocm9jLCBBVUM6OmF1YykKICApCgpyb2NzCmBgYAoKYGBge3J9CiMgQ29tcGFyYWNhbyBkZSBtb2RlbG9zCnJvY3MgJT4lCiAgZ2dwbG90KGFlcyh4ID0gYXVjLCB5ID0gbW9kZWxvLCBjb2xvdXIgPSBiYXNlKSkgKwogIGdlb21fcG9pbnQoc2l6ZSA9IDUpICsKICB0aGVtZV9taW5pbWFsKDMwKQpgYGAKCgpgYGB7cn0KIyBncsOhZmljbyBleHRyYSAtLS0tIGN1aWRhZG86IGPDs2RpZ29zIGRlIFIgYXZhbsOnYWRvcyEKcm9jX3Bsb3QgPC0gcm9jcyAlPiUKICBzZWxlY3QoYmFzZSwgbW9kZWxvLCByb2MpICU+JQogIG11dGF0ZSgKICAgIHJvYyA9IG1hcChyb2MsIH57CiAgICAgIC54ICU+JSAKICAgICAgICB1bmNsYXNzICU+JSAKICAgICAgICBhcy5kYXRhLmZyYW1lCiAgICB9KQogICkgJT4lCiAgdW5uZXN0ICU+JQogIGdncGxvdChhZXMoeCA9IGZwciwgeSA9IHRwciwgY29sb3VyID0gbW9kZWxvLCBsYWJlbCA9IGN1dG9mZnMpKSArCiAgZ2VvbV9saW5lKCkgKwogIGdlb21fYWJsaW5lKGNvbG91ciA9ICJncmV5NTAiKSArCiAgdGhlbWVfbWluaW1hbCgpICsKICBjb29yZF9maXhlZCgpICsKICBmYWNldF93cmFwKH5iYXNlKQoKcGxvdGx5OjpnZ3Bsb3RseShyb2NfcGxvdCkKYGBgCgoKCgoKIyBYR0Jvb3N0CgpFeGVyY8OtY2lvOiBBanVzdGUgdW0geGdib29zdCB1c2FuZG8gbyBjYXJldCBlIHJlc3BvbmRhOiBxdWFsIG1vZGVsbyBhcHJlc2VudGEgYSBtYWlvciBBVUM/IGNydGwrQyBjdHJsK1YgcG9yIHN1YSBjb250YSEKCkRJQ0EgMSkgdHJvcXVlICJyYW5nZXIiIHBvciAieGdiVHJlZSIKRElDQSAyKSByb2RlIGBpbmZvIDwtIGdldE1vZGVsSW5mbygieGdiVHJlZSIsIEZBTFNFKSR4Z2JUcmVlYCBlIGRlcG9pcyBjb25zdWx0ZSBgaW5mbyRwYXJhbWV0ZXJzYC4KRElDQSAzKSBleHBlcmltZW50ZSB1c2FyIG8gcGFyw6JtZXRybyBgdHVuZUxlbmd0aCA9IDIwYCBlbSB2ZXogZG8gYGB0dW5lR3JpZGAuCgpgYGB7cn0KZ2V0TW9kZWxJbmZvKCJ4Z2JUcmVlIiwgRkFMU0UpJHhnYlRyZWUKYGBgCgoKYGBge3J9CnRyYWluX2NvbnRyb2xfeGdiIDwtIHRyYWluQ29udHJvbCgKICBtZXRob2QgPSAiY3YiLAogIG51bWJlciA9IDUsCiAgY2xhc3NQcm9icyA9IFRSVUUsCiAgc3VtbWFyeUZ1bmN0aW9uID0gdHdvQ2xhc3NTdW1tYXJ5LAogIHZlcmJvc2VJdGVyID0gMSwKICBzZWFyY2ggPSAiZ3JpZCIKKQpgYGAKCgoKCmBgYHtyfQp0dW5lX2dyaWRfeGdiIDwtIGV4cGFuZC5ncmlkKAogIG5yb3VuZHMgICAgICAgICAgPSA1MDAsCiAgbWF4X2RlcHRoICAgICAgICA9IDYsCiAgZXRhICAgICAgICAgICAgICA9IDAuMDEsCiAgZ2FtbWEgICAgICAgICAgICA9IDUuNjM4NDkzNCwKICBjb2xzYW1wbGVfYnl0cmVlID0gMC40NDY0MzQ3LAogIG1pbl9jaGlsZF93ZWlnaHQgPSAxOS4wMDAwMDAwLAogIHN1YnNhbXBsZSAgICAgICAgPSAwLjkxMjgxNzIKKQoKbW9kZWxvX3hnYiA8LSB0cmFpbigKICByZWNlaXRhLAogIGNyZWRpdF9kYXRhICU+JSBmaWx0ZXIoYmFzZSAlaW4lICJ0cmVpbm8iKSAlPiUgc2VsZWN0KC1iYXNlKSwKICBtZXRob2QgPSAieGdiVHJlZSIsICNQUkVFTkNIQSBBUVVJCiAgbWV0cmljID0gIlJPQyIsCiAgdHJDb250cm9sID0gdHJhaW5fY29udHJvbF94Z2IsCiAgdHVuZUdyaWQgPSB0dW5lX2dyaWRfeGdiCikKCm1vZGVsb194Z2IkYmVzdFR1bmUgJT4lIHQKYGBgCgpgYGB7cn0KIyBQcmVkaWNvZXMKCmNyZWRpdF9kYXRhIDwtIGNyZWRpdF9kYXRhICU+JSAKICBtdXRhdGUoCiAgICBwcmVkX3hnYiA9IHByZWRpY3QobW9kZWxvX3hnYiwgLiwgdHlwZSA9ICJwcm9iIikkYmFkCiAgKQoKY3JlZGl0X2RhdGEgJT4lIHNlbGVjdChzdGFydHNfd2l0aCgicHJlZCIpLCBldmVyeXRoaW5nKCkpCmBgYAoKCmBgYHtyfQojY3VydmEgUk9DICAtLS0tIGN1aWRhZG86IGPDs2RpZ29zIGRlIFIgYXZhbsOnYWRvcyEKcm9jcyA8LSBjcmVkaXRfZGF0YSAlPiUKICBtdXRhdGUoCiAgICBTdGF0dXNfcGFyYV9yb2MgPSBmYWN0b3IoaWZfZWxzZShTdGF0dXMgPT0gImdvb2QiLCAwLCAxKSkKICApICU+JQogIHNlbGVjdChiYXNlLCBTdGF0dXNfcGFyYV9yb2MsIHN0YXJ0c193aXRoKCJwcmVkIikpICU+JQogIGdhdGhlcihtb2RlbG8sIHZhbG9yX3ByZWRpdG8sIHN0YXJ0c193aXRoKCJwcmVkIikpICU+JQogIGdyb3VwX2J5KGJhc2UsIG1vZGVsbykgJT4lCiAgbmVzdCgpICU+JQogIG11dGF0ZSgKICAgIHJvYyA9IG1hcChkYXRhLCB+IEFVQzo6cm9jKC54JHZhbG9yX3ByZWRpdG8sIC54JFN0YXR1c19wYXJhX3JvYykpLAogICAgYXVjID0gbWFwX2RibChyb2MsIEFVQzo6YXVjKQogICkKCnJvY3MKYGBgCgpgYGB7cn0KIyBDb21wYXJhY2FvIGRlIG1vZGVsb3MKcm9jcyAlPiUKICBnZ3Bsb3QoYWVzKHggPSBhdWMsIHkgPSBtb2RlbG8sIGNvbG91ciA9IGJhc2UpKSArCiAgZ2VvbV9wb2ludChzaXplID0gNSkgKwogIHRoZW1lX21pbmltYWwoMzApCmBgYAoKCmBgYHtyfQojIGdyw6FmaWNvIGV4dHJhIC0tLS0gY3VpZGFkbzogY8OzZGlnb3MgZGUgUiBhdmFuw6dhZG9zIQpyb2NfcGxvdCA8LSByb2NzICU+JQogIHNlbGVjdChiYXNlLCBtb2RlbG8sIHJvYykgJT4lCiAgbXV0YXRlKAogICAgcm9jID0gbWFwKHJvYywgfnsKICAgICAgLnggJT4lIAogICAgICAgIHVuY2xhc3MgJT4lIAogICAgICAgIGFzLmRhdGEuZnJhbWUKICAgIH0pCiAgKSAlPiUKICB1bm5lc3QgJT4lCiAgZ2dwbG90KGFlcyh4ID0gZnByLCB5ID0gdHByLCBjb2xvdXIgPSBtb2RlbG8sIGxhYmVsID0gY3V0b2ZmcykpICsKICBnZW9tX2xpbmUoKSArCiAgZ2VvbV9hYmxpbmUoY29sb3VyID0gImdyZXk1MCIpICsKICB0aGVtZV9taW5pbWFsKCkgKwogIGNvb3JkX2ZpeGVkKCkgKwogIGZhY2V0X3dyYXAofmJhc2UpCgpwbG90bHk6OmdncGxvdGx5KHJvY19wbG90KQpgYGA=